home *** CD-ROM | disk | FTP | other *** search
/ SuperHack / SuperHack CD.bin / CODING / GRAPHICS / 3DMORPH.ZIP / 3DMORPH.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-05-12  |  8.1 KB  |  280 lines
  1. {This very lame source is for all people who wants to code a 3d rotation in
  2.  Pascal.
  3.  There is also a little "morphing" in it. It is no real morph but looks
  4.  like one.(I think so...)
  5.  Sorry for being lazy! But I had no more time to write some comments.
  6.  But I think it's to understand the concept of 3d rotations.
  7.  You can optimize it like hell but never use the whole code and say it's
  8.  your own. Learn from it.
  9.  Ciao!
  10.  
  11.  Ryu D+P+S 12/05/1995  21:41
  12. }
  13. uses crt;
  14. const nump=100;
  15.       sintable : array[1..360] of integer =
  16.                   (0,2,4,6,8,11,13,15,17,20,22,24,26,28,30,33,35,37,39,41,43,
  17.                    45,47,50,52,54,56,58,60,62,63,65,67,69,71,73,75,77,78,80,
  18.                    82,83,85,87,88,90,92,93,95,96,98,99,100,102,103,104,106,
  19.                    107,108,109,110,111,113,114,115,116,116,117,118,119,120,
  20.                    121,121,122,123,123,124,124,125,125,126,126,126,127,127,
  21.                    127,127,127,127,127,128,127,127,127,127,127,127,127,126,
  22.                    126,126,125,125,124,124,123,123,122,121,121,120,119,118,
  23.                    117,116,116,115,114,113,111,110,109,108,107,106,104,103,
  24.                    102,100,99,98,96,95,93,92,90,88,87,85,83,82,80,78,77,75,73,
  25.                    71,69,67,65,63,62,60,58,56,54,52,50,47,45,43,41,39,37,35,
  26.                    33,30,28,26,24,22,20,17,15,13,11,8,6,4,2,0,-2,-4,-6,-8,-11,
  27.                    -13,-15,-17,-20,-22,-24,-26,-28,-30,-33,-35,-37,-39,-41,
  28.                    -43,-45,-47,-50,-52,-54,-56,-58,-60,-62,-64,-65,-67,-69,
  29.                    -71,-73,-75,-77,-78,-80,-82,-83,-85,-87,-88,-90,-92,-93,
  30.                    -95,-96,-98,-99,-100,-102,-103,-104,-106,-107,-108,-109,
  31.                    -110,-111,-113,-114,-115,-116,-116,-117,-118,-119,-120,
  32.                    -121,-121,-122,-123,-123,-124,-124,-125,-125,-126,-126,
  33.                    -126,-127,-127,-127,-127,-127,-127,-127,-128,-127,-127,
  34.                    -127,-127,-127,-127,-127,-126,-126,-126,-125,-125,-124,
  35.                    -124,-123,-123,-122,-121,-121,-120,-119,-118,-117,-116,
  36.                    -116,-115,-114,-113,-111,-110,-109,-108,-107,-106,-104,
  37.                    -103,-102,-100,-99,-98,-96,-95,-93,-92,-90,-88,-87,-85,-83,
  38.                    -82,-80,-78,-77,-75,-73,-71,-69,-67,-65,-64,-62,-60,-58,
  39.                    -56,-54,-52,-50,-47,-45,-43,-41,-39,-37,-35,-33,-30,-28,
  40.                    -26,-24,-22,-20,-17,-15,-13,-11,-8,-6,-4,-2);
  41.  
  42.       costable : array[1..360] of integer =
  43.                   (128,127,127,127,127,127,127,127,126,126,126,125,125,124,
  44.                    124,123,123,122,121,121,120,119,118,117,116,116,115,114,
  45.                    113,111,110,109,108,107,106,104,103,102,100,99,98,96,95,93,
  46.                    92,90,88,87,85,83,82,80,78,77,75,73,71,69,67,65,64,62,60,
  47.                    58,56,54,52,50,47,45,43,41,39,37,35,33,30,28,26,24,22,20,
  48.                    17,15,13,11,8,6,4,2,0,-2,-4,-6,-8,-11,-13,-15,-17,-20,-22,
  49.                    -24,-26,-28,-30,-33,-35,-37,-39,-41,-43,-45,-47,-50,-52,
  50.                    -54,-56,-58,-60,-62,-63,-65,-67,-69,-71,-73,-75,-77,-78,
  51.                    -80,-82,-83,-85,-87,-88,-90,-92,-93,-95,-96,-98,-99,-100,
  52.                    -102,-103,-104,-106,-107,-108,-109,-110,-111,-113,-114,
  53.                    -115,-116,-116,-117,-118,-119,-120,-121,-121,-122,-123,
  54.                    -123,-124,-124,-125,-125,-126,-126,-126,-127,-127,-127,
  55.                    -127,-127,-127,-127,-128,-127,-127,-127,-127,-127,-127,
  56.                    -127,-126,-126,-126,-125,-125,-124,-124,-123,-123,-122,
  57.                    -121,-121,-120,-119,-118,-117,-116,-116,-115,-114,-113,
  58.                    -111,-110,-109,-108,-107,-106,-104,-103,-102,-100,-99,-98,
  59.                    -96,-95,-93,-92,-90,-88,-87,-85,-83,-82,-80,-78,-77,-75,
  60.                    -73,-71,-69,-67,-65,-64,-62,-60,-58,-56,-54,-52,-50,-47,
  61.                    -45,-43,-41,-39,-37,-35,-33,-30,-28,-26,-24,-22,-20,-17,
  62.                    -15,-13,-11,-8,-6,-4,-2,0,2,4,6,8,11,13,15,17,20,22,24,26,
  63.                    28,30,33,35,37,39,41,43,45,47,50,52,54,56,58,60,62,64,65,
  64.                    67,69,71,73,75,77,78,80,82,83,85,87,88,90,92,93,95,96,98,
  65.                    99,100,102,103,104,106,107,108,109,110,111,113,114,115,116,
  66.                    116,117,118,119,120,121,121,122,123,123,124,124,125,125,
  67.                    126,126,126,127,127,127,127,127,127,127);
  68.  
  69. var xkoord,ykoord,zkoord:array[1..nump]of integer;
  70.     xkoord2,ykoord2,zkoord2:array[1..nump]of integer;
  71.     objx,objy,objz:array[1..nump]of integer;
  72.     lastofs:array[1..nump]of word;
  73.     centerx,centery:word;
  74.     a1,a2,a3:integer;
  75.     i,i2,a:word;
  76.     x,y,z:integer;
  77. procedure init320x200;assembler;
  78. asm
  79. mov  ax, 13h
  80. int  10h
  81. end;
  82.  
  83. procedure putpix(x,y:word;color:byte);assembler;
  84. asm
  85. push 0a000h
  86. pop  es
  87. mov  cx, y
  88. mov  ax, 320
  89. mul  cx
  90. mov  di, ax
  91. add  di, x
  92. mov  al, color
  93. stosb
  94. end;
  95.  
  96. procedure killpix(ofs:word);assembler;
  97. asm
  98. push 0a000h
  99. pop  es
  100. mov  di, ofs
  101. xor  al, al
  102. stosb
  103. @bye:
  104. end;
  105.  
  106. procedure setcolor(color,r,g,b:byte);assembler;
  107. asm
  108. mov  dx, 3c8h
  109. mov  al, color
  110. out  dx, al
  111. inc  dx
  112. mov  al, r
  113. out  dx, al
  114. mov  al, g
  115. out  dx, al
  116. mov  al, b
  117. out  dx, al
  118. end;
  119.  
  120. procedure retrace;
  121. begin
  122. repeat until (port[$3DA] and 8) = 0;
  123. repeat until (port[$3DA] and 8) > 0;
  124. end;
  125.  
  126. procedure disp;
  127. var x1,y1:word;
  128. begin
  129. retrace;
  130. for i:=1 to nump do begin
  131.  killpix(lastofs[i]);
  132.  x1:=(xkoord2[i] shl 7) div (zkoord2[i]+128)+centerx;
  133.  y1:=(ykoord2[i] shl 7) div (zkoord2[i]+128)+centery;
  134.  IF (x1<320) AND (y1<200) THEN BEGIN
  135.   putpix(x1,y1,15);
  136.   lastofs[i]:=320*y1+x1;
  137.  END ELSE lastofs[i]:=64001;
  138. end;
  139. end;
  140.  
  141. procedure rotate(yangle:word);
  142. begin
  143.  for i:=1 to nump do begin
  144.   x:=xkoord[i]*costable[yangle]-zkoord[i]*sintable[yangle];
  145.   z:=xkoord[i]*sintable[yangle]+zkoord[i]*costable[yangle];
  146.   xkoord2[i]:=x div 128;
  147.   ykoord2[i]:=ykoord[i];
  148.   zkoord2[i]:=z div 128;
  149.  end;
  150. end;
  151.  
  152. procedure calcball;
  153. var a2:real;
  154. begin
  155. a2:=1;
  156. for i:=1 to nump do begin
  157.  objx[i]:=sintable[round(a2)]*50 div 128;
  158.  objy[i]:=costable[round(a2)]*50 div 128;
  159.  objz[i]:=0;
  160.  a2:=a2+3.6;
  161. end;
  162. end;
  163.  
  164. procedure calccube;
  165. begin
  166. a1:=-30;
  167. a2:=-30;
  168. a3:=-30;
  169. for i:=1 to nump do begin
  170.  objx[i]:=a1;
  171.  objy[i]:=a2;
  172.  objz[i]:=a3;
  173.  inc(a1,10);
  174.  if a1=20 then begin
  175.   a1:=-30;
  176.   inc(a2,10);
  177.  end;
  178.  
  179.  if a2=20 then begin
  180.  a2:=-30;
  181.  inc(a3,10);
  182.  end;
  183. end;
  184. end;
  185.  
  186. procedure calcsquare;
  187. begin
  188. for i:=1 to 25 do begin
  189.  objx[i]:=-55+(i*5);
  190.  objy[i]:=-50;
  191.  objz[i]:=0;
  192. end;
  193. for i:=25 to 50 do begin
  194.  objx[i]:=-60+((i-24)*5);
  195.  objy[i]:=75;
  196.  objz[i]:=0;
  197. end;
  198. for i:=50 to 75 do begin
  199.  objx[i]:=-55;
  200.  objy[i]:=-50+((i-50)*5);
  201.  objz[i]:=0;
  202. end;
  203. for i:=75 to 100 do begin
  204.  objx[i]:=65;
  205.  objy[i]:=-50+((i-75)*5);
  206.  objz[i]:=0;
  207. end;
  208. end;
  209.  
  210. procedure calcrandom;
  211. begin
  212. randomize;
  213. for i:=1 to nump do begin
  214.  objx[i]:=random(150)-75;
  215.  objy[i]:=random(100)-50;
  216.  objz[i]:=random(100)-50;
  217. end;
  218. end;
  219.  
  220. procedure calccyl;
  221. var a2:real;
  222. begin
  223. a1:=-50;
  224. a2:=0;
  225. for i:=1 to nump do begin
  226.  objx[i]:=sintable[round(a2)]*20 div 128;
  227.  objy[i]:=costable[round(a2)]*20 div 128;
  228.  objz[i]:=a1;
  229.  IF (i mod 10)=0 then begin
  230.   a2:=0;
  231.   inc(a1,10);
  232.  end;
  233.  a2:=a2+360/10;
  234. end;
  235.  
  236. end;
  237.  
  238. procedure easymorph;
  239. begin
  240. for i:=1 to nump do begin
  241.  IF xkoord[i]<objx[i] THEN inc(xkoord[i]);
  242.  IF ykoord[i]<objy[i] THEN inc(ykoord[i]);
  243.  IF zkoord[i]<objz[i] THEN inc(zkoord[i]);
  244.  IF xkoord[i]>objx[i] THEN dec(xkoord[i]);
  245.  IF ykoord[i]>objy[i] THEN dec(ykoord[i]);
  246.  IF zkoord[i]>objz[i] THEN dec(zkoord[i]);
  247. end;
  248. end;
  249.  
  250. begin
  251. init320x200;
  252. randomize;
  253. for i:=1 to nump do begin
  254.  xkoord[i]:=random(150)-75;
  255.  ykoord[i]:=random(100)-50;
  256.  zkoord[i]:=random(100)-50;
  257. end;
  258. centerx:=160;
  259. centery:=100;
  260. i2:=1;
  261. repeat
  262.  IF i2=1 then calcrandom;
  263.  IF i2=250 then calccube;
  264.  IF i2=500 then calcball;
  265.  IF i2=750 then calcsquare;
  266.  IF i2=1000 then calccyl;
  267.  easymorph;
  268.  inc(i2);
  269.  IF i2=1250 then i2:=1;
  270.  rotate(a);
  271.  disp;
  272.  IF a<359 THEN inc(a,2) else a:=1;
  273. until keypressed;
  274. textmode(co80);
  275. writeln('Coding by Ryu/D+P+S');
  276. writeln('There is no music!');
  277. writeln('But, what can you expect? It was coded during the Spots! (WerbePause?)');
  278. writeln('Greetz fly to: Madness/D+P+S, Seppel, MiLKMAN, rouge, ToPBaNaNa');
  279. delay(900);
  280. end.